home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / basic / apg_2.exe / MAINT.SKL < prev    next >
Encoding:
Text File  |  1993-02-20  |  18.0 KB  |  746 lines
  1. XX ''''''''''''''''''''''''''''''''''''''''''''''''''
  2. XX '                                                '
  3. XX '                    INVENTORY                   '
  4. XX '                                                '
  5. XX '                 CREATED BY APG                 '
  6. XX '                                                '
  7. XX '                 S & M SOFTWARE                 '
  8. XX '                                                '
  9. XX '                 COPYRIGHT 1993                 '
  10. XX '                                                '
  11. XX '                                                '
  12. XX '  Author: John N Shankland                      '
  13. XX '  Date:   01-28-1993                            '
  14. XX '  Time:   10:43:36                              '
  15. XX '                                                '
  16. XX ''''''''''''''''''''''''''''''''''''''''''''''''''
  17.  
  18. DEFINT A-Z
  19. CONST FALSE = 0, TRUE = NOT FALSE
  20. TYPE rectype                                'Define variables for file
  21. XX    inbr AS STRING * 10
  22. XX    desc AS STRING * 30
  23. XX    num1 AS DOUBLE
  24. XX    num2 AS INTEGER
  25. XX    num3 AS SINGLE
  26. XX    num4 AS SINGLE
  27.    sts AS STRING * 1
  28. END TYPE
  29. TYPE indextype                              'Define index
  30.    recnum AS INTEGER
  31. XX    inbr AS STRING * 10
  32. END TYPE
  33. DECLARE FUNCTION getinput$ (work$, fl%, nflg$, plen, prec, form$, act$, mode$)
  34. DECLARE SUB arrow (mode$, opt$, tracfld)
  35. DECLARE SUB clearfore ()
  36. DECLARE SUB displaydata ()
  37. DECLARE SUB export ()
  38. DECLARE SUB message (msg$, resp$)
  39. DECLARE SUB newrec (recnum, numofrec, maxrec, newkey$, exit$, mode$)
  40. DECLARE SUB nextrec (direc$, exit$, numofrec, recnum)
  41. DECLARE SUB sortindex ()
  42. DIM SHARED numofrec
  43. XX DIM SHARED f7.2$
  44. XX DIM SHARED f4.0$
  45. XX DIM SHARED f2.2$
  46. XX DIM SHARED f0.3$
  47. XX DIM SHARED inv AS rectype
  48. XX f7.2$ = "########.##"
  49. XX f4.0$ = "#####"
  50. XX f2.2$ = "###.##"
  51. XX f0.3$ = "#.###"
  52.  
  53. ON ERROR GOTO errhandle
  54.  
  55. COLOR 15, 0
  56. CLS
  57.  
  58. XX OPEN "inv.dat" FOR RANDOM AS #1 LEN = LEN(inv)
  59.  
  60. XX numofrec = LOF(1) \ LEN(inv)
  61. maxrec = numofrec + 100
  62. DIM SHARED index(1 TO maxrec)  AS indextype
  63. IF numofrec <> 0 THEN
  64.    FOR recnum = 1 TO numofrec
  65. XX       GET #1, recnum, inv
  66.       index(recnum).recnum = recnum
  67. XX index(recnum).inbr = inv.inbr
  68.    NEXT
  69. END IF
  70. '
  71. '----- Print menu -----'
  72. '
  73. XX LOCATE 1, 35
  74. COLOR 7, 9
  75. XX PRINT " INVENTORY " '
  76. XX LOCATE 2, 35
  77. XX PRINT "MAINTENANCE" '
  78. sortindex                                   'sort records
  79. recnum = 0                                  'reset record number
  80.  
  81. XX LOCATE 4, 10: PRINT "01-Item number "
  82. XX LOCATE 6, 5: PRINT "02-Description      "
  83. XX LOCATE 7, 5: PRINT "03-num 7.2          "
  84. XX LOCATE 8, 5: PRINT "04-num 4.0          "
  85. XX LOCATE 9, 5: PRINT "05-num 2.2          "
  86. XX LOCATE 10, 5: PRINT "06-num 4 0.3        "
  87. '
  88. '----- Start processing -----'
  89. '
  90. start:
  91. mode$ = ""
  92. XX inv.inbr = ""
  93. XX inv.desc = ""
  94. XX inv.num1 = 0
  95. XX inv.num2 = 0
  96. XX inv.num3 = 0
  97. XX inv.num4 = 0
  98. XX inv.sts = ""
  99. nflg$ = ""
  100. clearfore
  101. XX LOCATE 4, 26
  102. XX newkey$ = getinput$(inv.inbr, 10, "S", 0, 0, "", act$, mode$)
  103. IF act$ = "PU" OR act$ = "PD" THEN
  104.    opt$ = act$
  105.    IF recnum = 0 THEN
  106.       IF opt$ = "PU" AND numofrec <> 0 THEN recnum = numofrec + 1
  107.    END IF
  108.    GOTO menu10
  109. END IF
  110. XX IF newkey$ = "          " GOTO fin
  111. XX IF UCASE$(newkey$) = "N         " THEN
  112.    opt$ = "N"
  113.    GOTO menu10
  114. END IF
  115. GOTO io
  116. '
  117. '------ Option bar -----'
  118. '
  119. menu:
  120. mode$ = "C"
  121. LOCATE 23, 1
  122. PRINT STRING$(80, " ")
  123. LOCATE 23, 12, 1
  124. COLOR 7, 9
  125. PRINT "FIELD #, PgUp, PgDn, ";
  126. PRINT "All, Next, Back, Delete, Sort, Export";
  127. COLOR 15, 0
  128. PRINT "  "
  129. COLOR 15, 9
  130. LOCATE 23, 18: PRINT "#"
  131. LOCATE 23, 33: PRINT "A"
  132. LOCATE 23, 38: PRINT "N"
  133. LOCATE 23, 44: PRINT "B"
  134. LOCATE 23, 50: PRINT "D"
  135. LOCATE 23, 58: PRINT "S"
  136. LOCATE 23, 64: PRINT "E"
  137.  
  138. COLOR 15, 0
  139. opt$ = ""
  140. menu5:
  141. LOCATE 23, 71
  142. PRINT opt$;
  143. DO
  144. instr$ = INKEY$
  145. LOOP WHILE instr$ = ""
  146.  
  147. IF INSTR("BANDSE", UCASE$(instr$)) > 0 THEN opt$ = instr$: GOTO menu10
  148. IF instr$ = CHR$(13) GOTO menu10
  149. IF instr$ = CHR$(27) GOTO menu
  150. IF instr$ = CHR$(8) GOTO menu
  151. IF LEN(instr$) = 2 THEN
  152.    code = ASC(RIGHT$(instr$, 1))
  153.    IF code = &H49 THEN opt$ = "PU"
  154.    IF code = &H51 THEN opt$ = "PD"
  155.    GOTO menu10
  156. END IF
  157. opt$ = opt$ + instr$
  158. GOTO menu5
  159. '
  160. '----- Start here for action keys -----'
  161. '
  162. menu10:  
  163. resp$ = ""
  164. IF opt$ = "" THEN GOTO start
  165. opt$ = UCASE$(opt$)
  166. IF MID$(opt$, 1, 1) = "0" THEN opt$ = MID$(opt$, 2, 1)
  167. LOCATE 23, 1
  168. PRINT STRING$(80, " ")
  169. LOCATE 23, 6, 1
  170. COLOR 7, 9
  171. IF INSTR("SEBNPUPD", opt$) = 0 THEN
  172. PRINT "Active Keys: <PgUp>, <PgDn>, <Arrows>, <Del>, <Ins>, <Esc> or <Enter>";
  173. COLOR 15, 9
  174. LOCATE 23, 20: PRINT "PgUp";
  175. LOCATE 23, 28: PRINT "PgDn";
  176. LOCATE 23, 36: PRINT "Arrows";
  177. LOCATE 23, 46: PRINT "Del";
  178. LOCATE 23, 53: PRINT "Ins";
  179. LOCATE 23, 60: PRINT "Esc";
  180. LOCATE 23, 69: PRINT "Enter";
  181. END IF
  182. COLOR 15, 0
  183.  
  184. SELECT CASE opt$
  185.    CASE "1"
  186.       message "Can not change index - Press any key", resp$
  187.       GOTO menu
  188. XX    CASE "2"                                 'Description
  189. XX       GOTO fld20
  190. XX    CASE "3"
  191. XX       GOTO fld30
  192. XX    CASE "4"
  193. XX       GOTO fld40
  194. XX    CASE "5"
  195. XX       GOTO fld50
  196. XX    CASE "6"
  197. XX       GOTO fld60
  198.    CASE "A"
  199.       mode$ = "A"
  200.       GOTO fld20
  201.    CASE "N", "PD"
  202.       direc$ = "F"
  203.       nextrec direc$, exit$, numofrec, recnum
  204.       IF exit$ = "A" GOTO start
  205.       GOTO menu
  206.    CASE "B", "PU"
  207.       direc$ = "B"
  208.       nextrec direc$, exit$, numofrec, recnum
  209.       IF exit$ = "A" GOTO start
  210.       GOTO menu
  211.    CASE "D"
  212. XX inv.sts = "D"
  213.       GOTO del
  214.    CASE "S"
  215.       resp$ = "1"
  216.       message "Sorting file - Please wait", resp$
  217.       sortindex
  218.       resp$ = "2"
  219.       message "", resp$
  220.    CASE "E"
  221.       CLOSE (2)
  222. XX KILL "john.exp"
  223.       resp$ = "1"
  224.       message "Preparing file for export - Please wait", resp$
  225.       export
  226.       resp$ = "2"
  227.       message "", resp$
  228. XX GET #1, recnum, john
  229. END SELECT
  230. GOTO menu
  231. '
  232. '----- Input fields -----'
  233. '
  234. XX fld20:                                 ' Description
  235. XX tracfld = 2
  236. XX LOCATE 6, 26
  237. XX inv.desc = getinput$(inv.desc, 30, "S", 0, 0, "", act$, mode$)
  238. XX LOCATE 25, 1
  239. XX PRINT STRING$(80, " ");
  240. XX IF inv.desc = "                              " AND mode$ <> "C" THEN
  241. XX    GOTO start
  242. XX END IF
  243. XX IF mode$ = "C" OR act$ <> "" GOTO add
  244. XX
  245. XX fld30:
  246. XX tracfld = 3
  247. XX LOCATE 7, 26
  248. XX IF mode$ = "N" THEN
  249. XX num1$ = STRING$(11, " ")
  250. XX ELSE
  251. XX num1$ = STR$(inv.num1) + STRING$(11, " ")
  252. XX END IF
  253. XX inv.num1 = VAL(getinput$(num1$, 11, "N", 7, 2, f7.2$, act$, mode$))
  254. XX IF mode$ = "C" OR act$ <> "" GOTO add
  255. XX
  256. XX fld40:
  257. XX tracfld = 4
  258. XX LOCATE 8, 26
  259. XX IF mode$ = "N" THEN
  260. XX num2$ = STRING$(6, " ")
  261. XX ELSE
  262. XX num2$ = STR$(inv.num2) + STRING$(6, " ")
  263. XX END IF
  264. XX inv.num2 = VAL(getinput$(num2$, 6, "N", 4, 0, f4.0$, act$, mode$))
  265. XX IF mode$ = "C" OR act$ <> "" GOTO add
  266. XX
  267. XX fld50:
  268. XX tracfld = 5
  269. XX LOCATE 9, 26
  270. XX IF mode$ = "N" THEN
  271. XX num3$ = STRING$(6, " ")
  272. XX ELSE
  273. XX num3$ = STR$(inv.num3) + STRING$(6, " ")
  274. XX END IF
  275. XX inv.num3 = VAL(getinput$(num3$, 6, "N", 2, 2, f2.2$, act$, mode$))
  276. XX IF mode$ = "C" OR act$ <> "" GOTO add
  277. XX
  278. XX fld60:
  279. XX tracfld = 6
  280. XX LOCATE 10, 26
  281. XX IF mode$ = "N" THEN
  282. XX num4$ = STRING$(5, " ")
  283. XX ELSE
  284. XX num4$ = STR$(inv.num4) + STRING$(5, " ")
  285. XX END IF
  286. XX inv.num4 = VAL(getinput$(num4$, 5, "N", 0, 3, f0.3$, act$, mode$))
  287. XX IF mode$ = "C" OR act$ <> "" GOTO add
  288. '
  289. '----- Add or change record or field -----'
  290. '
  291. add:                                        'Add record
  292. newrec recnum, numofrec, maxrec, newkey$, exit$, mode$
  293. IF exit$ = "Y" THEN GOTO fin
  294. IF act$ = "" GOTO menu
  295. IF act$ = "PD" THEN direc$ = "F"
  296. IF act$ = "PU" THEN direc$ = "B"
  297. IF act$ = "PD" OR act$ = "PU" THEN
  298.    nextrec direc$, exit$, numofrec, recnum
  299.    IF exit$ = "A" GOTO start
  300.    GOTO menu10
  301. END IF
  302. IF mode$ = "N" THEN mode$ = "Z"
  303. IF act$ = "AU" THEN
  304.    IF tracfld - 1 < 2 THEN
  305.       BEEP
  306.       tracfld = 3
  307.    END IF
  308.    opt$ = MID$(STR$(tracfld - 1), 2)
  309.    GOTO menu10
  310. END IF
  311. IF act$ = "AD" THEN
  312. XX    IF tracfld + 1 > 6 THEN
  313.       BEEP
  314. XX tracfld = 5
  315.    END IF
  316.    opt$ = MID$(STR$(tracfld + 1), 2)
  317.    GOTO menu10
  318. END IF
  319.  
  320. del:                                        'Delete record
  321. XX PUT #1, index(recnum).recnum, inv
  322. XX inv.sts = ""
  323. GOTO start
  324. '
  325. '----- Set for new or get exsisting record -----'
  326. '
  327. io:
  328. FOR recnum = 1 TO numofrec
  329. XX    IF index(recnum).inbr = newkey$ THEN GOTO io10
  330. NEXT
  331.    mode$ = "N"
  332. XX inv.inbr = newkey$
  333.    resp$ = "1"
  334.    message "New record - Enter field data or <ENTER> to abort", resp$
  335.    GOTO fld20
  336. io10:
  337. XX GET #1, index(recnum).recnum, inv
  338. XX IF inv.sts = "D" THEN
  339.    message "This record has been deleted - Do you wish to restore y/N ", resp$
  340.    IF UCASE$(resp$) = "Y" THEN
  341. XX inv.sts = ""
  342. XX       PUT #1, index(recnum).recnum, inv
  343.    ELSE
  344.       GOTO start
  345.    END IF
  346. END IF
  347. displaydata
  348. GOTO menu
  349. '
  350. '----- End program -----'
  351. '
  352. fin:
  353. CLS
  354. CLOSE
  355. XX RUN "zmenu"
  356. END
  357. '
  358. '----- Error handling -----'
  359. '
  360. errhandle:
  361. IF ERR = 53 THEN
  362.    RESUME NEXT
  363. END IF
  364. CLS
  365. PRINT "Unexpected error "; ERR
  366. PRINT "Please note this error number and consult your QuickBasic Manual!"
  367. INPUT "", a$
  368. CLOSE
  369. XX RUN "zmenu"
  370. END
  371.  
  372. SUB arrow (mode$, opt$, tracfld)
  373. IF mode$ = "AU" THEN
  374.    opt$ = MID$(STR$(tracfld - 1), 2)
  375.    EXIT SUB
  376. END IF
  377. IF mode$ = "AD" THEN
  378.    opt$ = MID$(STR$(tracfld + 1), 2)
  379.    EXIT SUB
  380. END IF
  381. END SUB
  382.  
  383. SUB clearfore
  384. COLOR 15, 0
  385. XX LOCATE 4, 26
  386. XX PRINT STRING$(10, " ")
  387. XX LOCATE 6, 26
  388. XX PRINT STRING$(30, " ")
  389. XX LOCATE 7, 26
  390. XX PRINT STRING$(11, " ")
  391. XX LOCATE 8, 26
  392. XX PRINT STRING$(6, " ")
  393. XX LOCATE 9, 26
  394. XX PRINT STRING$(6, " ")
  395. XX LOCATE 10, 26
  396. XX PRINT STRING$(5, " ")
  397. LOCATE 23, 1
  398. PRINT STRING$(80, " ")
  399. LOCATE 23, 4
  400. PRINT "Enter key information, <N> for next, <PgUp>, <PgDn>, or <ENTER> to exit"
  401. END SUB
  402.  
  403. SUB displaydata
  404. XX LOCATE 4, 26: PRINT inv.inbr
  405. XX LOCATE 6, 26: PRINT inv.desc
  406. XX LOCATE 7, 26: PRINT USING f7.2$; inv.num1
  407. XX LOCATE 8, 26: PRINT USING f4.0$; inv.num2
  408. XX LOCATE 9, 26: PRINT USING f2.2$; inv.num3
  409. XX LOCATE 10, 26: PRINT USING f0.3$; inv.num4
  410. END SUB
  411.  
  412. SUB export
  413. q$ = CHR$(34)
  414. XX OPEN "jphone.exp" FOR OUTPUT AS #2
  415.  
  416. FOR i = 1 TO numofrec
  417. XX GET #1, i, jphone
  418. XX data$ = q$ + jphone.newidx + q$ + ","
  419. XX data$ = data$ + q$ + jphone.idx + q$ + ","
  420. XX data$ = data$ + q$ + jphone.fname + q$
  421. PRINT #2, data$
  422. NEXT i
  423. END SUB
  424.  
  425. FUNCTION getinput$ (work$, fl, nflg$, plen, prec, form$, act$, mode$)
  426. '
  427. ' ----- set varailbles -----'
  428. '
  429. crow = CSRLIN
  430. ccol = POS(0)
  431. beg = ccol - 1
  432. maxcol = ccol + fl - 1
  433. mincol = ccol
  434. new$ = "N"
  435. act$ = ""
  436. GOTO begin5
  437. '
  438. ' ----- get inputed character -----'
  439. '
  440. begin:
  441. BEEP
  442. begin5:
  443. dotpos = INSTR(work$, ".")
  444. signpos = INSTR(work$, "-")
  445. IF dotpos = 0 THEN dot = 0
  446. IF signpos = 0 THEN sign = 0
  447. code = 0
  448. LOCATE crow, mincol, 1
  449. IF nflg$ = "L" OR edit$ = "Y" THEN PRINT work$;
  450. work# = VAL(work$)
  451. IF nflg$ = "N" AND edit$ = "" THEN PRINT USING form$; work#
  452. LOCATE crow, ccol, , 7
  453. IF insert$ = "Y" THEN LOCATE crow, ccol, 1, 0, 7
  454. DO
  455. instr$ = INKEY$
  456. LOOP WHILE instr$ = ""
  457. '
  458. ' ----- is it a special character? -----'
  459. '
  460. IF instr$ = CHR$(27) THEN work$ = STRING$(fl, " "): ccol = mincol: GOTO begin5
  461. IF instr$ = CHR$(8) THEN dir$ = "L": key$ = "B": GOTO begin10
  462. IF LEN(instr$) = 2 THEN
  463.    code = ASC(RIGHT$(instr$, 1))
  464.    IF code = &H4B THEN dir$ = "L": key$ = "L": GOTO begin10  'Left arrow
  465.    IF code = &H4D THEN dir$ = "R": key$ = "R": GOTO begin10  'Right arrow
  466.    IF code = &H4F THEN dir$ = "R": key$ = "E": GOTO begin10  'End
  467.    IF code = &H47 THEN dir$ = "L": key$ = "H": GOTO begin10  'Home
  468.    IF code = &H52 THEN                                           'Insert
  469.       IF insert$ = "" THEN
  470.          dir$ = "L"
  471.          key$ = "I"
  472.          insert$ = "Y"
  473.          GOTO begin10
  474.       ELSE
  475.          insert$ = ""
  476.          dir$ = "R"
  477.          key$ = "R"
  478.          GOTO begin10
  479.       END IF
  480.    END IF
  481.    IF code = &H53 THEN dir$ = "R": key$ = "D": GOTO begin10  'Delete
  482.    IF code = &H49 THEN act$ = "PU": GOTO begin10             'Page up
  483.    IF code = &H51 THEN act$ = "PD": GOTO begin10             'Page down
  484.    IF code = &H48 THEN act$ = "AU": GOTO begin10             'Up arrow
  485.    IF code = &H50 THEN act$ = "AD": GOTO begin10             'Down arrow
  486.    GOTO begin
  487. ELSE
  488. dir$ = "R": key$ = "R"
  489. END IF
  490. '
  491. ' ----- does this character request an exit? ------ '
  492. '
  493. begin10:
  494. IF instr$ = CHR$(13) OR LEN(act$) = 2 THEN
  495.    IF nflg$ = "L" THEN
  496.       getinput$ = work$
  497.       EXIT FUNCTION
  498.    ELSE
  499.       dec = INSTR(work$, ".")
  500.       IF dec = 0 AND edit$ = "Y" THEN
  501.          IF prec = 0 THEN
  502.             getinput$ = work$
  503.             EXIT FUNCTION
  504.          END IF
  505.          factor$ = "." + RIGHT$("000000000001", prec)
  506.          worknum# = VAL(work$) * VAL(factor$)'
  507.          getinput$ = STR$(worknum#)
  508.          EXIT FUNCTION
  509.        ELSE
  510.             getinput$ = work$
  511.             EXIT FUNCTION
  512.        END IF
  513.    END IF
  514. END IF
  515. IF code = 0 AND instr$ <> CHR$(8) GOTO valid
  516. '
  517. ' ----- perform action of special key ----- '
  518. '
  519. IF dir$ = "R" AND ccol = maxcol THEN GOTO begin
  520. IF dir$ = "L" AND ccol = mincol AND key$ = "B" AND LEN(RTRIM$(work$)) = 1 THEN
  521.    MID$(work$, 1, 1) = " ": GOTO begin5
  522. END IF
  523. IF dir$ = "L" AND ccol = mincol THEN GOTO begin
  524. SELECT CASE key$
  525.    CASE "L"
  526.       ccol = ccol - 1
  527.    CASE "R"
  528.       ccol = ccol + 1
  529.       IF ccol > maxcol THEN
  530.          BEEP
  531.          ccol = maxcol
  532.       END IF
  533.    CASE "E"
  534.       ccol = mincol + LEN(RTRIM$(work$))
  535.    CASE "H"
  536.       ccol = mincol
  537.    CASE "D"
  538.       work$ = MID$(work$, 1, ccol - beg - 1) + MID$(work$, ccol - beg + 1, fl) + " "
  539.    CASE "B"
  540.       work$ = MID$(work$, 1, ccol - beg - 2) + MID$(work$, ccol - beg, fl) + " "
  541.       ccol = ccol - 1
  542.    END SELECT
  543. GOTO begin5
  544. '
  545. ' ----- check validity of inputed character ----- '
  546. '
  547. valid:
  548.  
  549. IF nflg$ = "L" THEN
  550.    IF insert$ = "Y" THEN
  551.       work1$ = MID$(work$, 1, ccol - beg - 1)
  552.       work2$ = MID$(work$, ccol - beg, fl)
  553.       work$ = work1$ + instr$ + work2$
  554.       work$ = MID$(work$, 1, fl)
  555.       ccol = ccol + 1
  556.       IF ccol > maxcol THEN
  557.          ccol = maxcol
  558.          GOTO begin
  559.       END IF
  560.       GOTO begin5
  561.    END IF
  562.    MID$(work$, ccol - beg) = instr$
  563.    ccol = ccol + 1
  564.    IF ccol > maxcol THEN
  565.       ccol = maxcol
  566.       GOTO begin
  567.    END IF
  568.    GOTO begin5
  569. END IF
  570. IF new$ = "N" THEN
  571.    blen = plen + prec + 2
  572.    blank$ = STRING$(blen, " ")
  573.    work$ = blank$: new$ = ""
  574. END IF
  575. IF ccol = mincol THEN
  576.    PRINT work$
  577.    LOCATE crow, mincol
  578.    edit$ = "Y"
  579.    first = INSTR("-.1234567890", instr$)
  580.    SELECT CASE first
  581.       CASE 0
  582.          GOTO begin
  583.       CASE 1
  584.          sign = 1
  585.          GOTO accept
  586.       CASE 2
  587.          IF dot = 1 THEN
  588.             GOTO begin
  589.          END IF
  590.          dot = 1
  591.          GOTO accept
  592.    END SELECT
  593.    GOTO accept
  594. END IF
  595. other = INSTR(".1234567890", instr$)
  596. SELECT CASE other
  597.    CASE 0
  598.       GOTO begin
  599.    CASE 1
  600.       IF dot = 1 THEN
  601.          GOTO begin
  602.       END IF
  603.       dot = 1
  604.       GOTO accept
  605. END SELECT
  606. GOTO accept
  607. '
  608. ' ------ accept valid numeric and manipulate ----- '
  609. '
  610. accept:
  611. IF prec = 0 THEN
  612.    IF instr$ = "." AND ccol <> mincol + plen + sign GOTO begin
  613.    maxlen = plen + sign + dot
  614.    IF LEN(RTRIM$(work$)) = maxlen THEN
  615.       GOTO begin
  616.    ELSE
  617.       MID$(work$, ccol - beg) = instr$
  618.       ccol = ccol + 1
  619.       GOTO accept10
  620.    END IF
  621. END IF
  622.  
  623. dotpos = INSTR(work$, ".")
  624. IF dotpos = 0 THEN
  625.    maxlen = plen + sign
  626.    IF LEN(RTRIM$(work$)) = maxlen THEN
  627.       IF instr$ <> "." THEN
  628.          MID$(work$, ccol - beg) = "." + instr$
  629.          ccol = ccol + 2
  630.          GOTO accept10
  631.       ELSE
  632.          MID$(work$, ccol - beg) = instr$
  633.          ccol = ccol + 1
  634.          GOTO accept10
  635.       END IF
  636.    ELSE
  637.       MID$(work$, ccol - beg) = instr$
  638.       ccol = ccol + 1
  639.       GOTO accept10
  640.    END IF
  641. ELSE
  642.    IF instr$ = "." THEN GOTO begin
  643.    maxlenpr = prec + dotpos
  644.    IF prec = 0 THEN maxlenpr = plen
  645.    IF LEN(RTRIM$(work$)) = maxlenpr THEN
  646.       GOTO begin
  647.    ELSE
  648.       MID$(work$, ccol - beg) = instr$
  649.       ccol = ccol + 1
  650.       GOTO accept10
  651.    END IF
  652. END IF
  653. accept10:
  654. GOTO begin5
  655.  
  656. END FUNCTION
  657.  
  658. SUB message (msg$, resp$)
  659. '
  660. ' resp$ = "" wait for response
  661. ' resp$ = "1" don't clear message, exit
  662. ' resp$ = "2" clear message, exit
  663. '
  664. IF resp$ = "2" THEN GOTO msg10
  665. IF resp$ = "" THEN BEEP
  666. Y = (80 - LEN(msg$)) / 2
  667. LOCATE 23, 1
  668. PRINT STRING$(80, " ")
  669. LOCATE 25, Y, 0
  670. PRINT msg$;
  671. IF resp$ = "1" THEN EXIT SUB
  672. DO
  673. resp$ = INKEY$
  674. LOOP WHILE resp$ = ""
  675. LOCATE 25, Y
  676. PRINT STRING$(LEN(msg$), " ");
  677. EXIT SUB
  678. msg10:
  679. LOCATE 25, 1
  680. PRINT STRING$(80, " ");
  681. END SUB
  682.  
  683. SUB newrec (recnum, numofrec, maxrec, newkey$, exit$, mode$)
  684. IF mode$ = "N" THEN
  685.    numofrec = numofrec + 1
  686.    IF numofrec = maxrec THEN
  687.       message "Can not add any more records this session - Restart", resp$
  688.       exit$ = "Y"
  689.    END IF
  690. XX PUT #1, numofrec, inv                       'Add new record
  691.    index(numofrec).recnum = numofrec
  692. XX index(numofrec).inbr = newkey$
  693. ELSE
  694. XX    PUT #1, index(recnum).recnum, inv        'Write changed record
  695. END IF
  696. END SUB
  697.  
  698. SUB nextrec (direc$, exit$, numofrec, recnum)
  699. exit$ = ""
  700. IF direc$ = "F" THEN recnum = recnum + 1
  701. IF direc$ = "B" THEN recnum = recnum - 1
  702. IF recnum > numofrec THEN
  703.    message "End of file - Press any key", resp$
  704.    recnum = 0
  705.    exit$ = "A"
  706.    EXIT SUB
  707. END IF
  708. IF recnum = 0 THEN
  709.    message "Start of file - Press any key", resp$
  710.    exit$ = "A"
  711.    EXIT SUB
  712. END IF
  713. XX GET #1, index(recnum).recnum, inv
  714. XX IF inv.sts = "D" THEN
  715.    message "This record has been deleted - Do you wish to restore y/N ", resp$
  716.    IF UCASE$(resp$) = "Y" THEN
  717. XX inv.sts = ""
  718. XX    PUT #1, index(recnum).recnum, inv
  719.    ELSE
  720.       exit$ = "A"
  721.       EXIT SUB
  722.    END IF
  723. END IF
  724. displaydata
  725. END SUB
  726.  
  727. SUB sortindex STATIC
  728. SHARED index() AS indextype, numofrec
  729. offset = numofrec \ 2
  730. DO WHILE offset > 0
  731.    limit = numofrec - offset
  732.    DO
  733.       switch = FALSE
  734.       FOR i = 1 TO limit
  735. XX          IF index(I).inbr > index(I + offset).inbr THEN
  736.             SWAP index(i), index(i + offset)
  737.             switch = i
  738.          END IF
  739.       NEXT i
  740.       limit = switch
  741.    LOOP WHILE switch
  742.    offset = offset \ 2
  743. LOOP
  744. END SUB
  745.  
  746.